Delphi Magazine Collection 2001/Delphi Magazine Collection 20001 (2001).iso/DISKS/Issue35/system/RichEdit2.pas

Pascal/Delphi Source File | 1998-06-09 | 7.9 KB | 255 lines

unit RichEdit2;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  StdCtrls, ComCtrls, RichEdit;

type
    PCharRange = ^TCharRange;
    TURLClickedEvent = procedure (Sender: TObject; const TheURL: String; Button: TMouseButton) of object;

    TUndoRedoType = ( uidUnknown, uidTyping, uidDelete, uidDragDrop, uidCut, uidPaste );

    TRichEdit2 = class (TCustomRichEdit)
    private
        { Private declarations }
        fLibHandle: THandle;
        fURLHighlight: Boolean;
        fUndoLimit: Integer;
        fURLClicked: TURLClickedEvent;
        fLastCR: TCharRange;
        procedure SetURLHighlight (Value: Boolean);
        function GetRow: Integer;
        function GetColumn: Integer;
        function GetGotSelection: Boolean;
        function GetFirstLine: Integer;
        function GetBoolProp (Index: Integer): Boolean;
        procedure SetUndoLimit (Value: Integer);
        function GetUndoRedoType (Index: Integer): TUndoRedoType;
        procedure WMNCDestroy (var Message: TWMNCDestroy); message wm_NCDestroy;
        procedure CNNotify(var Message: TWMNotify); message cn_Notify;
    protected
        { Protected declarations }
        procedure CreateWnd; override;
        procedure CreateParams (var Params: TCreateParams); override;
        procedure URLLinkNotification (Link: Pointer);
    public
        { Public declarations }
        constructor Create (AOwner: TComponent); override;
    published
        { Published declarations }
        property Align;
        property Alignment;
        property BorderStyle;
        property Color;
        property Ctl3D;
        property DragCursor;
        property DragMode;
        property Enabled;
        property Font;
        property HideSelection;
        property HideScrollBars;
        property ImeMode;
        property ImeName;
        property Lines;
        property MaxLength;
        property ParentColor;
        property ParentCtl3D;
        property ParentFont;
        property ParentShowHint;
        property PlainText;
        property PopupMenu;
        property ReadOnly;
        property ScrollBars;
        property ShowHint;
        property TabOrder;
        property TabStop;
        property Visible;
        property WantTabs;
        property WantReturns;
        property WordWrap;
        property OnChange;
        property OnDragDrop;
        property OnDragOver;
        property OnEndDrag;
        property OnEnter;
        property OnExit;
        property OnKeyDown;
        property OnKeyPress;
        property OnKeyUp;
        property OnMouseDown;
        property OnMouseMove;
        property OnMouseUp;
        property OnResizeRequest;
        property OnSelectionChange;
        property OnStartDrag;
        property OnProtectChange;
        property OnSaveClipboard;
        property URLHighlight: Boolean read fURLHighlight write SetURLHighlight default True;
        property OnURLClicked: TURLClickedEvent read fURLClicked write fURLClicked;
        property GotSelection: Boolean read GetGotSelection;
        property Row: Integer read GetRow;
        property Column: Integer read GetColumn;
        property FirstLine: Integer read GetFirstLine;
        property CanUndo: Boolean index 0 read GetBoolProp;
        property CanRedo: Boolean index 1 read GetBoolProp;
        property UndoLimit: Integer read fUndoLimit write SetUndoLimit default 100;
        property UndoType: TUndoRedoType index 0 read GetUndoRedoType;
        property RedoType: TUndoRedoType index 1 read GetUndoRedoType;
    end;

procedure Register;

implementation

{$R *.DCR}

constructor TRichEdit2.Create (AOwner: TComponent);
begin
    Inherited Create (AOwner);
    fUndoLimit := 100;
    fURLHighlight := True;
end;

procedure TRichEdit2.CreateWnd;
var
    mask: Integer;
begin
    Inherited CreateWnd;
    mask := Perform (em_GetEventMask, 0, 0) or enm_Link;
    Perform (em_SetEventMask, 0, mask);
    Perform (em_AutoURLDetect, Ord (fURLHighlight), 0);
end;

procedure TRichEdit2.SetURLHighlight (Value: Boolean);
begin
    if Value <> fURLHighlight then begin
        fURLHighlight := Value;
        Perform (em_AutoURLDetect, Ord (fURLHighlight), 0);
    end;
end;

procedure TRichEdit2.CreateParams (var Params: TCreateParams);
const
    HideScrollBars: array[Boolean] of Longint = (ES_DISABLENOSCROLL, 0);
    HideSelections: array[Boolean] of Longint = (ES_NOHIDESEL, 0);
var
    OldError: Longint;
begin
    OldError := SetErrorMode (sem_NoOpenFileErrorBox);
    fLibHandle := LoadLibrary ('RICHED20.DLL');
    SetErrorMode (OldError);
    if (fLibHandle > 0) and (fLibHandle < hInstance_Error) then fLibHandle := 0;

    inherited CreateParams (Params);
    if fLibHandle <> 0 then CreateSubClass (Params, 'RICHEDIT20A')
    else CreateSubClass (Params, 'RICHEDIT');

    with Params do
    begin
        Style := Style or HideScrollBars [Inherited HideScrollBars] or HideSelections[HideSelection];
        WindowClass.style := WindowClass.style and not (cs_HRedraw or cs_VRedraw);
    end;
end;

procedure TRichEdit2.URLLinkNotification (Link: Pointer);
type
    // Need to redefine this - RICHTEXT.PAS gets it wrong!
    TTextRange = record
        chrg: TCharRange;
        lpstrText: PAnsiChar;
    end;
var
    sz: String;
    TextRange: TTextRange;
    pENLink: ^TENLink absolute Link;
begin
    with pENLink^ do begin
        SetLength (sz, chrg.cpMax - chrg.cpMin);
        TextRange.chrg := chrg;
        TextRange.lpstrText := Pointer (sz);
        Perform (em_GetTextRange, 0, Integer (@TextRange));
        case Msg of
            wm_MouseMove:         ;
            wm_LButtonDown:  if Assigned (fURLClicked) then fURLClicked (Self, sz, mbLeft);
            wm_MButtonDown:  if Assigned (fURLClicked) then fURLClicked (Self, sz, mbMiddle);
            wm_RButtonDown:  if Assigned (fURLClicked) then fURLClicked (Self, sz, mbRight);
        end;
    end;
end;

procedure TRichEdit2.CNNotify (var Message: TWMNotify);
begin
    if Message.NMHdr^.Code <> en_Link then Inherited else URLLinkNotification (Message.NMHdr);
end;

procedure TRichEdit2.WMNCDestroy (var Message: TWMNCDestroy);
begin
    Inherited;
    if fLibHandle <> 0 then FreeLibrary (fLibHandle);
end;

function TRichEdit2.GetGotSelection: Boolean;
begin
    Perform (em_ExGetSel, 0, Integer (@fLastCR));
    Result := fLastCR.cpMin <> fLastCR.cpMax;
end;

function TRichEdit2.GetRow: Integer;
var
    cp: Integer;
begin
    cp := -1;
    if GetGotSelection then cp := fLastCR.cpMin;
    Result := Perform (em_LineFromChar, cp, 0) + 1;
end;

function TRichEdit2.GetColumn: Integer;
var
    lp: Integer;
begin
    lp := Perform (em_LineIndex, -1, 0);
    if GetGotSelection then lp := Perform (em_LineIndex, Perform (em_ExLineFromChar, 0, fLastCR.cpMin), 0);
    Result := fLastCR.cpMin - lp + 1;
end;

function TRichEdit2.GetFirstLine: Integer;
begin
    Result := Perform (em_GetFirstVisibleLine, 0, 0);
end;

function TRichEdit2.GetBoolProp (Index: Integer): Boolean;
begin
    Result := False;  { Stop compiler whinging }
    case Index of
        0:     Result := Perform (em_CanUndo, 0, 0) <> 0;
        1:     Result := Perform (em_CanRedo, 0, 0) <> 0;
    end;
end;

procedure TRichEdit2.SetUndoLimit (Value: Integer);
begin
    if (fUndoLimit <> Value) and (Value >= 10) and (Value <= 400) then begin
        fUndoLimit := Value;
        Perform (em_SetUndoLimit, Value, 0);
    end;
end;

function TRichEdit2.GetUndoRedoType (Index: Integer): TUndoRedoType;
begin
    Result := uidUnknown;  { Stop compiler whinging }
    case Index of
        0:     Result := TUndoRedoType (Perform (em_GetUndoName, 0, 0));
        1:     Result := TUndoRedoType (Perform (em_GetRedoName, 0, 0));
    end;
end;

procedure Register;
begin
  RegisterComponents('XFactor', [TRichEdit2]);
end;

end.